home *** CD-ROM | disk | FTP | other *** search
/ Visual Basic Graphics Programming (2nd Edition) / Visual Basic Graphics Programming 2nd Edition.iso / Src / Ch14 / AltGrid.cls next >
Text File  |  1999-06-22  |  9KB  |  308 lines
  1. VERSION 1.0 CLASS
  2. BEGIN
  3.   MultiUse = -1  'True
  4.   Persistable = 0  'NotPersistable
  5.   DataBindingBehavior = 0  'vbNone
  6.   DataSourceBehavior  = 0  'vbNone
  7.   MTSTransactionMode  = 0  'NotAnMTSObject
  8. END
  9. Attribute VB_Name = "AltitudeGrid3d"
  10. Attribute VB_GlobalNameSpace = False
  11. Attribute VB_Creatable = False
  12. Attribute VB_PredeclaredId = False
  13. Attribute VB_Exposed = False
  14. Option Explicit
  15.  
  16. Private Xmin As Single      ' Min X and Y values.
  17. Private Zmin As Single
  18. Private Dx As Single        ' Spacing between rows of data.
  19. Private Dz As Single
  20. Private NumX As Integer     ' Number of X and Y entries.
  21. Private NumZ As Integer
  22. Private points() As Point3D ' Data values.
  23.  
  24. Public RemoveHidden As Boolean
  25.  
  26. Public MinColor As Long
  27. Public MaxColor As Long
  28.  
  29. Private Type POINTAPI
  30.     X As Long
  31.     Y As Long
  32. End Type
  33. Private Declare Function Polygon Lib "gdi32" (ByVal hdc As Long, lpPoint As POINTAPI, ByVal nCount As Long) As Long
  34.  
  35. ' Generate the fractal surface.
  36. Public Sub GenerateSurface(ByVal divisions As Integer, ByVal Dy As Single)
  37. Dim oldpoints() As Point3D
  38. Dim oldx As Integer
  39. Dim oldz As Integer
  40. Dim factor As Integer
  41. Dim newx As Integer
  42. Dim newz As Integer
  43. Dim i As Integer
  44. Dim j As Integer
  45. Dim newi As Integer
  46. Dim newj As Integer
  47.  
  48.     ' Make room for the new data.
  49.     factor = 2 ^ divisions
  50.     newx = (NumX - 1) * factor + 1
  51.     newz = (NumZ - 1) * factor + 1
  52.  
  53.     ' Copy the original data.
  54.     ReDim oldpoints(1 To NumX, 1 To NumZ)
  55.     For i = 1 To NumX
  56.         For j = 1 To NumZ
  57.             oldpoints(i, j) = points(i, j)
  58.         Next j
  59.     Next i
  60.  
  61.     ' Resize and initialize the Points array.
  62.     oldx = NumX
  63.     oldz = NumZ
  64.     SetBounds Xmin, Dx / factor, newx, _
  65.               Zmin, Dz / factor, newz
  66.  
  67.     ' Move the old data to the new positions.
  68.     newi = 1
  69.     For i = 1 To oldx
  70.         newj = 1
  71.         For j = 1 To oldz
  72.             points(newi, newj) = oldpoints(i, j)
  73.             newj = newj + factor
  74.         Next j
  75.         newi = newi + factor
  76.     Next i
  77.  
  78.     ' Subdivide each area in the data.
  79.     newi = 1
  80.     For i = 2 To oldx
  81.         newj = 1
  82.         For j = 2 To oldz
  83.             Subdivide newi, newi + factor, _
  84.                       newj, newj + factor, Dy
  85.             newj = newj + factor
  86.         Next j
  87.         newi = newi + factor
  88.     Next i
  89. End Sub
  90. ' If a Y value is within distance range of the
  91. ' value target_y, then reduce that distance by
  92. ' a factor of smooth_factor.
  93. Public Sub Flatten(ByVal target_y As Single, ByVal range As Single, ByVal smooth_factor As Single)
  94. Dim i As Integer
  95. Dim j As Integer
  96. Dim diff As Single
  97.  
  98.     For i = 1 To NumX
  99.         For j = 1 To NumZ
  100.             With points(i, j)
  101.                 diff = .coord(2) - target_y
  102.                 If Abs(diff) < range Then
  103.                     .coord(2) = target_y + smooth_factor * diff
  104.                 End If
  105.             End With
  106.         Next j
  107.     Next i
  108. End Sub
  109.  
  110. ' Recursively subdivide the indicated area.
  111. Private Sub Subdivide(ByVal i1 As Integer, ByVal i2 As Integer, ByVal j1 As Integer, ByVal j2 As Integer, ByVal Dy As Single)
  112. Dim y11 As Single
  113. Dim y12 As Single
  114. Dim y21 As Single
  115. Dim y22 As Single
  116. Dim imid As Integer
  117. Dim jmid As Integer
  118.  
  119.     If (i2 - i1 <= 1) Or (j2 - j1 <= 1) Then Exit Sub
  120.  
  121.     ' Compute the midpoint locations.
  122.     y11 = points(i1, j1).coord(2)
  123.     y12 = points(i1, j2).coord(2)
  124.     y21 = points(i2, j1).coord(2)
  125.     y22 = points(i2, j2).coord(2)
  126.  
  127.     imid = (i1 + i2) \ 2
  128.     jmid = (j1 + j2) \ 2
  129.     points(i1, jmid).coord(2) = (y11 + y12) / 2 + 2 * Dy * Rnd - Dy
  130.     points(i2, jmid).coord(2) = (y21 + y22) / 2 + 2 * Dy * Rnd - Dy
  131.     points(imid, j1).coord(2) = (y11 + y21) / 2 + 2 * Dy * Rnd - Dy
  132.     points(imid, j2).coord(2) = (y12 + y22) / 2 + 2 * Dy * Rnd - Dy
  133.     points(imid, jmid).coord(2) = (y11 + y12 + y21 + y22) / 4 + 2 * Dy * Rnd - Dy
  134.  
  135.     ' Recursively subdivide the four new areas.
  136.     Subdivide i1, imid, j1, jmid, Dy / 2
  137.     Subdivide imid, i2, j1, jmid, Dy / 2
  138.     Subdivide i1, imid, jmid, j2, Dy / 2
  139.     Subdivide imid, i2, jmid, j2, Dy / 2
  140. End Sub
  141.  
  142. ' Create the Points array.
  143. Public Sub SetBounds(ByVal x1 As Single, ByVal deltax As Single, ByVal xnum As Integer, ByVal z1 As Single, ByVal deltaz As Single, ByVal znum As Integer)
  144. Dim i As Integer
  145. Dim j As Integer
  146. Dim X As Single
  147. Dim Z As Single
  148.  
  149.     Xmin = x1
  150.     Zmin = z1
  151.     Dx = deltax
  152.     Dz = deltaz
  153.     NumX = xnum
  154.     NumZ = znum
  155.     ReDim points(1 To NumX, 1 To NumZ)
  156.     
  157.     X = Xmin
  158.     For i = 1 To NumX
  159.         Z = Zmin
  160.         For j = 1 To NumZ
  161.             points(i, j).coord(1) = X
  162.             points(i, j).coord(2) = 0
  163.             points(i, j).coord(3) = Z
  164.             points(i, j).coord(4) = 1#
  165.             Z = Z + Dz
  166.         Next j
  167.         X = X + Dx
  168.     Next i
  169. End Sub
  170. ' Save the indicated data value.
  171. Public Sub SetValue(ByVal X As Single, ByVal Y As Single, ByVal Z As Single)
  172. Dim i As Integer
  173. Dim j As Integer
  174.  
  175.     i = (X - Xmin) / Dx + 1
  176.     j = (Z - Zmin) / Dz + 1
  177.     points(i, j).coord(2) = Y
  178. End Sub
  179.  
  180. ' Apply a transformation matrix which may not
  181. ' contain 0, 0, 0, 1 in the last column to the
  182. ' object.
  183. Public Sub ApplyFull(M() As Single)
  184. Dim i As Integer
  185. Dim j As Integer
  186.  
  187.     For i = 1 To NumX
  188.         For j = 1 To NumZ
  189.             m3ApplyFull points(i, j).coord, M, points(i, j).trans
  190.         Next j
  191.     Next i
  192. End Sub
  193.  
  194. ' Apply a transformation matrix to the object.
  195. Public Sub Apply(M() As Single)
  196. Dim i As Integer
  197. Dim j As Integer
  198.  
  199.     For i = 1 To NumX
  200.         For j = 1 To NumZ
  201.             m3Apply points(i, j).coord, M, points(i, j).trans
  202.         Next j
  203.     Next i
  204. End Sub
  205.  
  206.  
  207. ' Draw the transformed points on a PictureBox.
  208. Public Sub Draw(ByVal pic As Object)
  209. Dim i As Integer
  210. Dim j As Integer
  211. Dim api_points(1 To 4) As POINTAPI
  212. Dim ymin As Single
  213. Dim ymax As Single
  214. Dim new_value As Single
  215. Dim min_r As Single
  216. Dim min_g As Single
  217. Dim min_b As Single
  218. Dim max_r As Single
  219. Dim max_g As Single
  220. Dim max_b As Single
  221. Dim dr As Single
  222. Dim dg As Single
  223. Dim db As Single
  224. Dim mid_y As Single
  225. Dim altitude As Single
  226.  
  227.     On Error Resume Next
  228.  
  229.     ' See if we should fill the "rectangles."
  230.     If RemoveHidden Then
  231.         pic.FillStyle = vbFSSolid
  232.         pic.FillColor = vbWhite
  233.     Else
  234.         pic.FillStyle = vbFSTransparent
  235.     End If
  236.  
  237.     ' Find the minimum and maximum Y values.
  238.     ymin = points(1, 1).coord(2)
  239.     ymax = ymin
  240.     For i = 1 To NumX
  241.         For j = 1 To NumZ
  242.             new_value = points(i, j).coord(2)
  243.             If ymin > new_value Then ymin = new_value
  244.             If ymax < new_value Then ymax = new_value
  245.         Next j
  246.     Next i
  247.  
  248.     ' Calculate the change in color values
  249.     ' per unit.
  250.     min_r = MinColor And &HFF&
  251.     min_g = (MinColor And &HFF00&) \ &H100&
  252.     min_b = (MinColor And &HFF0000) \ &H10000
  253.     max_r = MaxColor And &HFF&
  254.     max_g = (MaxColor And &HFF00&) \ &H100&
  255.     max_b = (MaxColor And &HFF0000) \ &H10000
  256.     dr = (max_r - min_r) / (ymax - ymin)
  257.     dg = (max_g - min_g) / (ymax - ymin)
  258.     db = (max_b - min_b) / (ymax - ymin)
  259.  
  260.     ' Draw the "rectangles."
  261.     For i = 1 To NumX - 1
  262.         For j = 1 To NumZ - 1
  263.             ' Load the POINTAPI array.
  264.             With api_points(1)
  265.                 .X = points(i, j).trans(1)
  266.                 .Y = points(i, j).trans(2)
  267.             End With
  268.             With api_points(2)
  269.                 .X = points(i + 1, j).trans(1)
  270.                 .Y = points(i + 1, j).trans(2)
  271.             End With
  272.             With api_points(3)
  273.                 .X = points(i + 1, j + 1).trans(1)
  274.                 .Y = points(i + 1, j + 1).trans(2)
  275.             End With
  276.             With api_points(4)
  277.                 .X = points(i, j + 1).trans(1)
  278.                 .Y = points(i, j + 1).trans(2)
  279.             End With
  280.  
  281.             ' Get the middle altitude.
  282.             mid_y = ( _
  283.                 points(i, j).coord(2) + _
  284.                 points(i + 1, j).coord(2) + _
  285.                 points(i + 1, j + 1).coord(2) + _
  286.                 points(i, j + 1).coord(2)) / 4
  287.             altitude = mid_y - ymin
  288.  
  289.             ' Set the area's color.
  290.             pic.FillColor = RGB( _
  291.                 min_r + dr * altitude, _
  292.                 min_g + dg * altitude, _
  293.                 min_b + db * altitude)
  294.  
  295.             ' Draw the area.
  296.             Polygon pic.hdc, api_points(1), 4
  297.         Next j
  298.     Next i
  299. End Sub
  300.  
  301. ' Set some default colors.
  302. Private Sub Class_Initialize()
  303.     MinColor = vbBlue
  304.     MaxColor = vbRed
  305. End Sub
  306.  
  307.  
  308.